The goal for this lab report is to properly classify the images in the training portion of the “image-woof” dataset. In order to do this, we need to use transfer learning to perform feature extraction. Unfortunately, since we have 12454 images in our dataset, we have to batch the dataset and then perform feature extraction on individual batches. Figuring out how to do this is left as an exercise for the reader. As we have completed this prior to beginning classification, we proceed simply by reading the data matrix and image lookup files into R.

First we will be loading the libraries necessary for performing this procedure.

library(readr)
library(keras)
library(ggplot2)
library(data.table)
library(dplyr)
## 
## Attaching package: 'dplyr'
## The following objects are masked from 'package:data.table':
## 
##     between, first, last
## The following objects are masked from 'package:stats':
## 
##     filter, lag
## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union
library(plyr)
## -------------------------------------------------------------------------
## You have loaded plyr after dplyr - this is likely to cause problems.
## If you need functions from both plyr and dplyr, please load plyr first, then dplyr:
## library(plyr); library(dplyr)
## -------------------------------------------------------------------------
## 
## Attaching package: 'plyr'
## The following objects are masked from 'package:dplyr':
## 
##     arrange, count, desc, failwith, id, mutate, rename, summarise,
##     summarize

Next, let’s take a look at an example photo. This is just one of the many dogs that we will attempt to classify in this lab.

image_path <- "imagewoof-320/train/n02086240/n02086240_513.jpeg"
image <- image_load(image_path, target_size = c(429,320))
image <- image_to_array(image)
image <- array_reshape(image, c(1, dim(image)))

par(mar = rep(0, 4L))
plot(0,0,xlim=c(0,1),ylim=c(0,1),axes= FALSE, type = "n", asp=1)
rasterImage(image[1,,,] / 255,0,0,1,1)

Again since we have 12454 images in our dataset, we have to batch the dataset and then perform feature extraction on individual batches. We have done this prior and thus will proceed simply by reading the data matrix and image lookup files into R. This has been done using resnet50 with average pooling layer.

X <- read_rds("my-image-embed.rds")
image_data <- read_csv("my-image-data.csv")
## Parsed with column specification:
## cols(
##   obs_id = col_character(),
##   train_id = col_character(),
##   class = col_double(),
##   class_name = col_character(),
##   path_to_image = col_character()
## )

In order for Keras to handle the analysis properly, we need to construct a data-matrix for training, as well as one hot encode our classes. Additionally, we store a copy of the original y file for PCA analysis at the end.

X_train <- X[image_data$train_id == "train",]
y <- to_categorical(image_data$class)
y_old <- image_data$class
y_train <- to_categorical(image_data$class[image_data$train_id == "train"])

Below, we run a simple dense neural net, with one minor difference from what we have typically done in class in the form that we use as our activation layer leaky relu as opposed to the simple relu.

model <- keras_model_sequential()
model %>%
  layer_dense(units = 512, input_shape = ncol(X_train)) %>%
  layer_activation_leaky_relu %>%
  layer_dropout(rate = 0.5) %>%

  layer_dense(units = 512) %>%
  layer_activation_leaky_relu %>%
  layer_dropout(rate = 0.5) %>%
  
  layer_dense(units = 512) %>%
  layer_activation_leaky_relu %>%
  layer_dropout(rate = 0.5) %>%

  layer_dense(units = ncol(y_train)) %>%
  layer_activation(activation = "softmax")

model %>% compile(loss = 'categorical_crossentropy',
                  optimizer = optimizer_rmsprop(lr = 0.0001),
                  metrics = c('accuracy'))

history <- model %>%
  fit(X_train, y_train, epochs = 8)
plot(history)

As we have now trained a neural network on our data matrix of features, we proceed by evaluating this neural networks performance on the validation dataset. As you can see, it performs quite well, with approximately 94.5% accuracy on the validation dataset.

y_pred <- predict_classes(model, X)
image_data$y_pred <- y_pred
tapply(image_data$class == y_pred, image_data$train_id, mean)
##     train     valid 
## 0.9705567 0.9419912

There is one minor hiccup in terms of properly analyzing the misclassified features, namely that they are labeled according to some nonsensical naming scheme. Fortunately, there is a lookup, so we simply merge the lookup onto our dataset. Unfortunately, in the course of merging our data, the merge function in R apparently sorts the data. Thus it is necessary to use the join function, and specifically the join function from the plyr package.

image_labels <- read_csv("image-labels.csv")
## Parsed with column specification:
## cols(
##   class_name = col_character(),
##   label = col_character()
## )
image_data<-join(image_data, image_labels, by="class_name")
image_data <-image_data[,c(1:7)]

Below, we provide a confusion matrix for the dataset. As you can see, the most confused categories are golden retrievers and samoyeds and dingals, and shih-tzus and old english sheepdogs.

library(forcats)
class_names <- filter(arrange(image_data,class),!duplicated(class))$label
table(value = factor(class_names[image_data$class + 1L], levels = class_names), prediction = image_data$y_pred, image_data$train_id)
## , ,  = train
## 
##                             prediction
## value                          0   1   2   3   4   5   6   7   8   9
##   Shih-Tzu                   761   1   2   0   1   4   3   5   3   0
##   Rhodesian ridgeback          0 766   1   1   0   0   6   0   0   6
##   beagle                       0   2 747  22   0   0   4   0   2   3
##   English foxhound             1   2  41 402   1   0   1   0   0   4
##   Border terrier               2   2   1   0 758   4   6   2   0   5
##   Australian terrier           5   1   1   1  13 746   7   2   0   4
##   golden retriever             1   3   0   0   1   0 766   0   5   4
##   Old English sheepdog,        5   0   0   1   0   3   0 765   5   1
##   Samoyed, Samoyede            0   0   0   0   1   0   1   0 778   0
##   dingo, warrigal, warragal,   0   6   3   1   2   0   3   0   2 763
## 
## , ,  = valid
## 
##                             prediction
## value                          0   1   2   3   4   5   6   7   8   9
##   Shih-Tzu                   492   3   5   0   4   1   6   7   1   1
##   Rhodesian ridgeback          0 491   6   5   0   1   8   0   1   8
##   beagle                       0   3 474  38   2   1   1   0   1   0
##   English foxhound             0   5  25 266   1   0   3   0   0   2
##   Border terrier               2   5   1   2 488  11   4   2   0   5
##   Australian terrier           9   1   2   2  11 483   5   3   2   2
##   golden retriever             1   3   3   0   2   1 501   1   2   6
##   Old English sheepdog,        5   0   1   0   0   3   2 495  14   0
##   Samoyed, Samoyede            0   0   0   0   0   0   6   0 514   0
##   dingo, warrigal, warragal,   1   9   4   2   1   3   3   0   8 489
y_probs <- predict(model, X)
id <- order(y_probs[which(image_data$y_pred == image_data$class),], decreasing = TRUE)
id <- apply(y_probs, 2, which.max)
image_data$y_pred[id]
##  [1] 0 1 2 3 4 5 6 7 8 9
par(mfrow = c(4, 8))
for (i in id) {
  par(mar = rep(0, 4L))
  plot(0,0,xlim=c(0,1),ylim=c(0,1),axes= FALSE,type = "n", asp=1)
  
  image_path <- image_data$path_to_image[i]
  image <- image_load(image_path, target_size = c(429,320))
  image <- image_to_array(image)
  image <- array_reshape(image, c(1, dim(image)))


  rasterImage(image[1,,,] /255,0,0,1,1)
  text(0.5, 0.1, label = image_data$label[i], col = "red", cex=1)
}

Additionally, we have included pictures of misclassified objects. Since there are so many pictures in the dataset, even a good performance on the dataset will misclassify a large number of images (although in absolute and not relative terms). As a result, we randomly selected 96 misclassified images and displayed them below. In most cases, it is quite hard for us at least to make out the correct species of dog.

par(mfrow = c(4, 8))
for (i in sample(which(image_data$y_pred != image_data$class),96)) {
  par(mar = rep(0, 4L))
  plot(0,0,xlim=c(0,1),ylim=c(0,1),axes= FALSE,type = "n")
  
  image_path <- image_data$path_to_image[i]
  image <- image_load(image_path, target_size = c(429,320))
  image <- image_to_array(image)
  image <- array_reshape(image, c(1, dim(image)))

  rasterImage(image[1,,,] /255,0,0,1,1)
  text(0.5, 0.1, label = image_data$label[i], col = "red", cex=1)
}

Finally, you can see the principal component analysis below:

pca <- as_tibble(prcomp(X)$x[,1:2])
pca$y <- class_names[y_old + 1L]

The thing to note here is that there appear to be around 8 distinct clusters, despite the fact that there are 10 different breeds of dog. This is exactly what you would expect given that the dataset was chosen for the difficulty to distinguish between breeds!

ggplot(pca, aes(PC1, PC2)) +
  geom_point(aes(color = y), alpha = 0.4, size = 2) +
  labs(x = "", y = "", color = "class") +
  theme_minimal()